    Baraj, ziua 2 (selectia lotului IOI, Cluj, mai 1996)
    Problema 4 (Problema aprovizion[rii)

     O retea de N (N10) magazine foloseste un camion pentru a se aproviziona cu 
un anumit produs de la cele 3 depozite en-gros cu care are contract. oferul 
camionului este pl[tit n functie de distanta total[ parcurs[ de la depozite la 
magazine, lundu-se n considerare doar drumurile cnd este nc[rcat (de la 
depozit la magazin). Camionul are capacitatea astfel nct poate transporta 
orice cantitate intervine n problem[, pentru a satisface toate cererile de la 
fiecare magazin. Fiind prieten cu patronul, acesta v-a promis un premiu 
substantial dac[ reusiti s[ g[siti o modalitate prin care soferul s[ fie pl[tit 
ct mai putin, adic[ prin care s[ se g[seasc[ ruta care minimizeaz[ drumurile 
pe care le are de f[cut soferul.
    Se cunosc stocurile x(i), i=1,3 din produsul respectiv, existente la fiecare 
dintre depozite si cererile r(j), j=1,N de la fiecare magazin.
Se mai impun urm[toarele conditii:
    - cantitatea total[ transportat[ de la orice depozit la magazin trebuie s[ 
fie egal[ cu cererea de la acel magazin;
    - nu se admit transbord[ri: nu se poate transporta marfa de la un depozit 
la alt depozit, sau de la un magazin la altul (nu se admit situatiile n care o 
parte din marf[ e l[sat[ la un magazin si restul dus[ la alt magazin sau la alt 
depozit).
Date de intrare:
Fisierul text, al c[rui nume se va citi de la tastatur[, va contine:
    - pe prima linie num[rul de magazine N;
    - urm[toarele linii vor contine distantele de la depozite la magazine (n 
ordinea cresc[toare a depozitelor): pe o linie, distantele de la un depozit la 
magazinele 1,2,...,N separate de un spatiu;
    - urm[toarele trei linii vor contine stocurile x(i) de la depozite;
    - urm[toarele N linii vor contine cererile r(j) de la magazine.
Date de iesire:
Fisierul text de iesire out.txt va contine:
    - pe prima linie distanta total[ minim[;
    - urm[toarele linii: pe cte o linie triplete de forma (i,j,k) cu 
semnificatia: se va parcurge drumul de la depozitul i la magazinul j 
transportnd cantitatea k.
    Aceast[ list[ de triplete va fi ordonat[ cresc[tor dup[ num[rul depozitului 
si pentru acelasi depozit, cresc[tor dup[ num[rul magazinului.
    In cazul n care nu se poate realiza un astfel de parcurs n conformitate cu 
cerintele enuntului se va afisa un mesaj corespunz[tor.
Observatie: 
Toate m[rimile care intervin n problem[ au valori ntregi, strict pozitive.
Exemplu:
Fie continutul fisierului de intrare:
4
2 2 3 3
1 2 1 3
4 5 1 6
10
10
3
8
7
5
2
Fisierul de iesire va contine:
8
1 2 7
1 4 2
2 1 8
2 3 2
3 3 3
Not[: Timp maxim de executare pentru fiecare test: 30 secunde.
           Punctaj maxim: 100 puncte.
=================================================
Solutia 1 (Mihai Badoiu):
{$A+,B-,D-,E+,F-,G+,I-,L-,N+,O-,P-,Q-,R-,S-,T-,V+,X+,Y-}
{$M 65520,0,655360}
const
    max=100;
var
    cost,v,s:array[1..max,1..max] of integer;
    ccc,t:array[1..max] of integer;
    m:array[1..max] of char;
    vs,p:array[1..max] of byte;
    n:integer;
    cost_total:integer;
    flux_total:integer;


procedure init;
var
    i,j:integer;
begin
    cost_total:=0;
    for i:=1 to n+5 do
             for j:=1 to n+5 do
                           s[i,j]:=v[i,j];
end;

function min(a,b:integer):integer;
begin
    if a<b then
             min:=a
    else
             min:=b;
end;

function marcat_dest:boolean;
var
    b:boolean;
    i,j:integer;
    minim:integer;
begin
    for i:=1 to n+5 do
    begin
                                   ccc[i]:=30000;
             t[i]:=0;
             vs[i]:=0;
             end;
    t[1]:=30000;
    ccc[1]:=0;
    vs[1]:=1;
    repeat
             b:=true;
             minim:=30000;
             for i:=1 to n+5 do
             if (vs[i]=1) and (minim>ccc[i]) then
                           minim:=ccc[i];
             if minim<>30000 then
                           b:=false;
             for i:=1 to n+5 do
             if (vs[i]=1) and (minim=ccc[i]) then
             begin
                           vs[i]:=2;
                           for j:=1 to n+5 do
                           if (s[i,j]>0) and (ccc[j]>ccc[i]+cost[i,j]) then
                           begin
                                              ccc[j]:=ccc[i]+cost[i,j];
                                              t[j]:=min(t[i],s[i,j]);
                                              vs[j]:=1;
                                              m[j]:='+';
                                              p[j]:=i;
                                              end;
                           for j:=1 to n+5 do
                           if (v[j,i]-s[j,i]>0) and (ccc[j]>ccc[i]-cost[j,i]) then
                           begin
                                              ccc[j]:=ccc[i]-cost[j,i];
                                              t[j]:=min(t[i],v[j,i]-s[j,i]);
                                              vs[j]:=1;
                                              m[j]:='-';
                                              p[j]:=i;
                                              end;
                           end;
    until b;
    if vs[n+5]=0 then
             marcat_dest:=false
    else
    begin
             flux_total:=flux_total+t[n+5];
             marcat_dest:=true;
             end;
end;

procedure traseaza_drum;
var
               i,j:integer;
begin
    i:=n+5;
    while i<>1 do
    begin
             if m[i]='+' then
             begin
                           cost_total:=cost_total+t[n+5]*cost[p[i],i];
                           dec(s[p[i],i],t[n+5]);
                           i:=p[i];
                           end
             else
             if m[i]='-' then
             begin
                           cost_total:=cost_total-t[n+5]*cost[i,p[i]];
                           inc(s[i,p[i]],t[n+5]);
                           i:=p[i];
                           end
             else
             begin
                           writeln('EROARE!!!');
                           halt;
                           end;
             end;
end;

procedure calcul;
begin
    init;
    while marcat_dest do
             traseaza_drum;
end;

procedure load;
var
    f:text;
    nume:string;
    i,j:integer;
begin
    write('nume fisier = ');
    readln(nume);
    assign(f,nume);
    reset(f);
    readln(f,n);
    for i:=1 to 3 do
    begin
             for j:=1 to n do
             begin
                           read(f,cost[i+1,j+4]);
                           v[i+1,j+4]:=maxint; {*}
                                                            end;
             readln(f);
             end;
    for i:=1 to 3 do
             readln(f,v[1,i+1]);
    for i:=1 to n do
             readln(f,v[i+4,n+5]);
    close(f);
end;

procedure scrie;
var
    i,j:integer;
    f:text;
    cost_cerut:integer;
    xmax:integer;
begin
    assign(f,'out.txt');
    rewrite(f);
    cost_cerut:=0;
    xmax:=0;
    for i:=5 to n+4 do
             xmax:=xmax+v[i,n+5];
    if xmax<>flux_total then
             writeln(f,'Nu exista solutie')
    else
    begin
             for i:=2 to 4 do
                           for j:=5 to n+4 do
                           if v[i,j]-s[i,j]<>0 then
                                              cost_cerut:=cost_cerut+cost[i,j];
             writeln(f,cost_cerut);
             for i:=2 to 4 do
                           for j:=5 to n+4 do
                           if v[i,j]-s[i,j]<>0 then
                           begin
                                              writeln(f,i-1,' ',j-4,' ',v[i,j]-s[i,j]);
                                              end;
             end;
    close(f);
end;

begin
    load;
    calcul;
    scrie;
end.
=============================
Solutia 2 (Catalin Francu):
program TrucksSuck;
{$B- I- R- S-}
const NDep=3;
      NMax=10;
type IntegerVector=array[1..NMax] of Integer;
     IntegerMatrix=array[1..NDep,1..NMax] of Integer;
     RealMatrix=array[1..NDep,1..NMax] of Real;
var R,Q,SR,SQ:IntegerVector; { Quantity reqtd., quantity available }
    N,TargetSum,TotalCost,STargetSum,BestTotalCost:Integer;
    D,Carry,BestCarry:IntegerMatrix;
    P:RealMatrix;      { Profit }

procedure ReadData;
var S:String;
    i,j:Integer;
begin
  Write('Numele fisierului de intrare: ');ReadLn(S);
  Assign(Input,S);Reset(Input);
  ReadLn(N);
  for i:=1 to NDep do
    begin
      for j:=1 to N do Read(D[i,j]);
      ReadLn;
    end;
  for i:=1 to NDep do ReadLn(Q[i]);
  TargetSum:=0;
  for i:=1 to N do begin
                         ReadLn(R[i]);
                         Inc(TargetSum,R[i]);
                       end;
  Close(Input);
  SR:=R;
  SQ:=Q;
  STargetSum:=TargetSum;
end;

function MaxCarry(i,j:Integer):Integer;
{ Cat se poate cara maxim de la depozitul i la magazinul j }
begin
  if Q[i]<R[j] then MaxCarry:=Q[i]
               else MaxCarry:=R[j];
end;

procedure FindMaxProfit(var X,Y:Integer);
{ Gaseste maximul matricii P }
var BestP:Real;
    i,j:Integer;
begin
  BestP:=0;
  for i:=1 to NDep do
    for j:=1 to N do
      if P[i,j]>BestP then begin
                             X:=i;
                             Y:=j;
                             BestP:=P[i,j];
                           end;
end;

procedure FindMaxProfit1(var X,Y:Integer);
{ Gaseste maximul matricii P }
var BestP:Real;
    i,j:Integer;
begin
  BestP:=0;
  for i:=NDep downto 1 do
    for j:=N downto 1 do
      if P[i,j]>BestP then begin
                             X:=i;
                             Y:=j;
                             BestP:=P[i,j];
                           end;
end;

procedure UpdateProfit(L,C:Integer);
{ Actualizeaza profitul in linia L si coloana C }
var i:Integer;
begin
  for i:=1 to N do
    P[L,i]:=MaxCarry(L,i)/D[L,i];
  for i:=1 to NDep do
    P[i,C]:=MaxCarry(i,C)/D[i,C];
end;

procedure FindIt1;
var i,j,k:Integer;
begin
  TotalCost:=0;
  for i:=1 to NDep do
    for j:=1 to N do
      begin
        P[i,j]:=MaxCarry(i,j)/D[i,j];
        Carry[i,j]:=0;
      end;
  while TargetSum>0 do
    begin
      FindMaxProfit(i,j);
      k:=MaxCarry(i,j);
      Inc(Carry[i,j],k);
      Dec(Q[i],k);
      Dec(R[j],k);
      Dec(TargetSum,k);
      Inc(TotalCost,D[i,j]);
      UpdateProfit(i,j);
    end;
  BestCarry:=Carry;BestTotalCost:=TotalCost;
end;

procedure Restore;
begin
  R:=SR;
  Q:=SQ;
  TargetSum:=STargetSum;
end;

procedure FindWorstShop(var X:Integer);
{ Gaseste un magazin a.i. minimul costurilor sa fie maxim }
var i,Min,Worst:Integer;
begin
  Worst:=0;
  for i:=1 to N do
    if R[i]>0 then begin
                     if D[1,i]<D[2,i] then Min:=D[1,i]
                                      else Min:=D[2,i];
                     if D[3,i]<Min then Min:=D[3,i];
                     if Min>Worst then begin
                                         Worst:=Min;
                                         X:=i;
                                       end;
                   end;
end;

procedure FindBestDep(var X:Integer;Y:Integer;var k:Integer);
{ Gaseste cel mai bun depozit pt. a cara marfa la magazinul Y }
var i,j:Integer;
    P,BestP:Real;
begin
  BestP:=0;
  for i:=1 to NDep do
    begin
      j:=MaxCarry(i,Y);
      P:=j/D[i,Y];
      if P>BestP then begin
                        X:=i;
                        k:=j;
                        BestP:=P;
                      end;
    end;
end;

procedure FindIt2;
var i,j,k:Integer;
begin
  TotalCost:=0;
  for i:=1 to NDep do
    for j:=1 to N do
      Carry[i,j]:=0;
  while TargetSum>0 do
    begin
      FindWorstShop(j);
      FindBestDep(i,j,k);
      Inc(Carry[i,j],k);
      Dec(Q[i],k);
      Dec(R[j],k);
      Dec(TargetSum,k);
      Inc(TotalCost,D[i,j]);
    end;
end;

procedure FindIt3;
var i,j,k:Integer;
begin
  TotalCost:=0;
  for i:=1 to NDep do
    for j:=1 to N do
      begin
        P[i,j]:=MaxCarry(i,j)/D[i,j];
        Carry[i,j]:=0;
      end;
  while TargetSum>0 do
    begin
      FindMaxProfit1(i,j);
      k:=MaxCarry(i,j);
      Inc(Carry[i,j],k);
      Dec(Q[i],k);
      Dec(R[j],k);
      Dec(TargetSum,k);
      Inc(TotalCost,D[i,j]);
      UpdateProfit(i,j);
    end;
end;

procedure Check;
begin
  if TotalCost<BestTotalCost
    then begin
           BestTotalCost:=TotalCost;
           BestCarry:=Carry;
         end;
end;

procedure WriteSolution;
var i,j:Integer;
begin
  WriteLn(BestTotalCost);
  for i:=1 to NDep do
    for j:=1 to N do
      if BestCarry[i,j]>0 then WriteLn(i,' ',j,' ',BestCarry[i,j]);
end;

begin
  ReadData;
  Assign(Output,'out.txt');Rewrite(Output);
  if Q[1]+Q[2]+Q[3]<TargetSum then WriteLn('Nu exista solutie.')
                              else begin
                                     FindIt1;
                                     Restore;
                                     FindIt2;
                                     Check;
                                     Restore;
                                     FindIt3;
                                     Check;
                                     WriteSolution;
                                   end;
  Close(Output);
end.
=================================
Solutia 3 (Ovidiu ghiorghioiu):
uses crt;
const nmax=10;
var dist:array[1..3,1..nmax] of integer;
    x:array[1..3] of integer;
    r:array[1..nmax] of integer;
    fi:text;
    s:string;
    i,j,k,n,nn,min,cost,cm,u,umin,uumin,s1,s2:integer;
    c,co,f,v,v0:array[0..nmax+4,0..nmax+4] of integer;
    m:array[0..nmax+4] of boolean;
procedure citeste;
begin
     write('Numele fis. de intrare: ');readln(s);
     assign(fi,s);
     reset(fi);
     readln(fi,n);
     for i:=1 to 3 do
         for j:=1 to n do read(fi,dist[i,j]);
     for i:=1 to 3 do read(fi,x[i]);
     for i:=1 to n do read(fi,r[i]);
     close(fi);
end;
procedure back(k:integer);
var umsave,i:integer;
begin
     m[k]:=true;
     umsave:=umin;
     if k=nn then
        if cost<min then begin
           min:=cost;
           uumin:=umin;
           v0:=v
        end
     else else
     for i:=1 to nn do if not m[i] then begin
         {k->i}
         u:=c[k,i]-f[k,i];
         if u>0 then begin
            if u<umsave then umin:=u else umin:=umsave;
            v[k,i]:=1;
            inc(cost,co[k,i]);
            back(i);
            dec(cost,co[k,i]);
            v[k,i]:=0;
         end;
         {i->k}
         u:=f[i,k];
         if u>0 then begin
            if u<umsave then umin:=u else umin:=umsave;
            v[i,k]:=-1;
            dec(cost,co[i,k]);
            back(i);
            inc(cost,co[i,k]);
            v[i,k]:=0;
         end
     end;
     m[k]:=false;
     umin:=umsave;
end;
procedure rezolva;
begin
     s1:=0;
     for i:=1 to n do inc(s1,r[i]);
     s2:=0;
     for i:=1 to 3 do inc(s2,x[i]);
     if s1>s2 then begin
        writeln(fi,'Nu exista solutie');
        close(fi);
        halt
     end;
     fillchar(c,sizeof(c),0);
     fillchar(f,sizeof(f),0);
     fillchar(co,sizeof(co),0);
     nn:=n+4;
     for i:=1 to n do c[0,i]:=r[i];
     for i:=1 to 3 do
         for j:=1 to n do begin
             c[j,n+i]:=r[j];
             co[j,n+i]:=dist[i,j]
         end;
     for i:=1 to 3 do c[n+i,nn]:=x[i];
     cm:=0;
     repeat
           fillchar(m,sizeof(m),false);
           fillchar(v,sizeof(v),0);
           min:=maxint;
           umin:=maxint;
           cost:=0;
           back(0);
           if min=maxint then exit;
           for i:=0 to nn do
               for j:=0 to nn do inc(f[i,j],uumin*v0[i,j]);
     until false;
end;
procedure scrie;
begin
     cm:=0;
     for i:=1 to 3 do
         for j:=1 to n do
             if f[j,n+i]<>0 then inc(cm,dist[i,j]);
     writeln(fi,cm);
     for i:=1 to 3 do
         for j:=1 to n do
             if f[j,n+i]<>0 then
                writeln(fi,i,' ',j,' ',f[j,n+i]);

end;
begin
     citeste;
     assign(fi,'out.txt');
     rewrite(fi);
     rezolva;
     scrie;
     close(fi)
end.
---------------------------------
Solutia 4 (Vlad Petric):
program p4;

var n:integer;
    cost:array[1..3,1..11] of integer;
    vi,ni,val,nec:array[1..11] of integer;
    cantit:integer;
    fo:text;

procedure citire;
var f:text;
    nf:string;
    i,j:integer;
begin
  write('Nume fisier:');
  readln(nf);
  assign(f,nf);
  reset(f);
  readln(f,n);
  for i:=1 to 3 do
    for j:=1 to n do
      read(f,cost[i,j]);
  for i:=1 to 3 do
    read(f,vi[i]);
  cantit:=0;
  for i:=1 to n do begin
    read(f,ni[i]);
    inc(cantit,ni[i]);
  end;
  val:=vi;
  nec:=ni;
end;

var sta,stb,stc,stma,stmb,stmc:array[1..30] of integer;
    sp:integer;
    smp,cm:integer;
procedure next(var a,b:integer);
begin
  if b=n then begin
    inc(a);
    b:=1;
  end
  else
    inc(b);
end;


procedure backtrack(x,y,cant,costu:integer);
var ct,cos,sv,sn,a,b,i,j:integer;
begin
  if (cant=cantit) then begin
    if (costu<cm) then begin
      stma:=sta;
      stmb:=stb;
      stmc:=stc;
      smp:=sp;
      cm:=costu;
    end
  end
  else begin
     if a=4 then
       exit;
     if (val[x]<>0) and (nec[y]<>0) then begin
       sv:=val[x];
       sn:=nec[y];
       ct:=cant;
       cos:=costu;
       inc(cos,cost[x,y]);
       inc(sp);
       sta[sp]:=x;
       stb[sp]:=y;
       if val[x]<=nec[y] then begin
         inc(ct,val[x]);
         stc[sp]:=val[x];
         dec(nec[y],val[x]);
         val[x]:=0;

       end
       else begin
         stc[sp]:=nec[y];
         inc(ct,nec[y]);
         dec(val[x],nec[y]);
         nec[y]:=ni[y];
       end;
       a:=x;
       b:=y;
       next(a,b);
       backtrack(a,b,ct,cos);
       dec(sp);
       val[x]:=sv;
       nec[y]:=sn;
     end;
     a:=x;
     b:=y;
     next(a,b);
     backtrack(a,b,cant,costu);
  end;
end;


var i:integer;
begin
  citire;
  assign(fo,'out.txt');
  rewrite(fo);
  cm:=maxint;
  backtrack(1,1,0,0);
  writeln(fo,cm);
  sp:=0;
  for i:=1 to smp do
    writeln(fo,stma[i],' ',stmb[i],' ',stmc[i]);
  close(fo);
end.
-----------------------------
